home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / C and C++ / Compilers⁄Interps / kevoSource / kevo.img < prev    next >
Text File  |  1993-05-13  |  36KB  |  990 lines
  1. (( Kevo Interactive Compiler Kernel                            ))
  2. (( Copyright Antero Taivalsaari 1991-1992                      ))
  3. (( Some parts copyright Antero Taivalsaari 1986-1988         ))
  4.  
  5. (( kevo.img: basic high-level definitions image file        ))
  6.  
  7. (( This file is represented in so-called immediate-free     ))
  8. (( form, which can be loaded into the Kevo kernel as such   ))
  9. (( without any compilation. Actual high-level definitions   ))
  10. (( of these operations would look more sophisticated.         ))
  11. (( -------------------------------------------------------- ))
  12.  
  13. (( Note that this file may still contain some non-object-oriented ))
  14. (( stuff which is not intended to be used any more.               ))
  15.  
  16. (( System root context (context = name space, dictionary) ))
  17. :: SystemRoot 2    (=context) 0 ;; 0
  18.  
  19. (( Basic user definition context ))
  20. :: Root 2        (=context) 0 ;; 0
  21.  
  22.  
  23. (( Task-specific areas which are not necessarily needed for all tasks. ))
  24. (( For safety, each execution stack has a four item underflow area ))
  25. :: (returnStack) 134 (( return stack: initially room for 128 items ))
  26.             (=context) DUMMY
  27.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  28.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0
  29.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  30.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0
  31.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  32.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0
  33.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  34.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 ;; 08
  35. :: (dataStack) 70     (( data stack: initially room for 64 items ))    
  36.             (=context) DUMMY
  37.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  38.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0
  39.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  40.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 ;; 08
  41. :: (contextStack) 38 (( context stack: initially room for 32 items ))
  42.             (=context) DUMMY
  43.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 
  44.             0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 ;; 08
  45. :: (trampoline) 4        0 0 0 0 ;; 08
  46. :: (textBuffer) 32      0 0 0 0 0 0 0 0 0 0   0 0 0 0 0 0 0 0 0 0 
  47.                         0 0 0 0 0 0 0 0 0 0   0 0 ;; 08
  48. :: (infileStack)  8        0 0 0 0   0 0 0 0 ;; 08
  49. :: (outfileStack) 4        0 0 0 0 ;; 08
  50.  
  51.  
  52. (( Task-specific variable area (each task has one of these areas).  ))
  53. (( Do not change the order of the first n fields (above the line),  ))
  54. (( because C primitives refer to them directly. ))
  55. (( If you nevertheless change the order, the corresponding changes  ))
  56. (( must be done in file 'tasks.h', and the Kevo system has to be    ))
  57. (( recompiled. ))
  58.  
  59. :: (user) 42 (( this must be increased when new task-specific vars are added ))
  60.     (=context) DUMMY            (( use the internal dummy (empty) context ))
  61.                                 (( so as to make area viewable by browser ))
  62.     (( nextInRobin ))    (user)    (( must point to itself ))
  63.     (( nextTask ))        0
  64.     (( rpStore ))        0
  65.     (( fp ))            0                (( frame pointer ))
  66.     (( priority ))        50                (( the current priority ))
  67.     (( returnStack ))    (returnStack)
  68.     (( dataStack ))        (dataStack)
  69.     (( contextStack ))    (contextStack)
  70.     (( trampoline ))     (trampoline)
  71.     (( textBuffer ))    (textBuffer)
  72.     (( textHead ))        0                (( text buffer offsets ))
  73.     (( textTail ))        0
  74.     (( eof ))            0                (( end of file flag ))
  75.     (( infiles ))        (infileStack)
  76.     (( outfiles ))        (outfileStack)
  77.     (( infile' ))        0
  78.     (( outfile' ))        0
  79.     (( infile ))        0
  80.     (( outfile ))        0
  81.     (( errfile ))        0
  82.     (( window ))        0
  83.     (( path ))            Root
  84.     (( assigning ))        0
  85.     (( error ))            oopError
  86.     (( ----------------------------------------------------------------))
  87.     (( user' ))            38        (( This must be increased if you add ))
  88.     (( compilation ))     0        (( new task variables ))
  89.     (( target ))         0
  90.     (( latest ))        0
  91.     (( frameSize ))        0
  92.     (( whoToModify ))    0
  93.     (( controls ))        0
  94.     (( warnings ))        0
  95.     (( tram' ))            0
  96.     (( comp' ))            0
  97.     (( text' ))            0
  98.     (( input ))            0
  99.     (( extra space ))    0 0 0 0 ;; 08
  100.  
  101. (( eof-field is referred to directly in operation 'setEof' so if you add new ))
  102. (( user variables, remember to change that too ))
  103.  
  104.  
  105. (( Offsets to task-specific system variables ))
  106.                     (( First four may not be referred to by the user ))
  107. (( :: nextInRobin 2 (=taskConst) 2 ;; 08 )) 
  108. (( :: nextTask 2     (=taskConst) 3 ;; 08 ))
  109. (( :: rpStore 2        (=taskConst) 4 ;; 08 ))
  110. (( :: fp 2            (=taskConst) 5 ;; 08 )) (( temp variable frame pointer ))
  111.  
  112. :: priority 2        (=taskVar) 6 ;; 00    (( the priority of the task ))
  113.  
  114. :: returnStack 2    (=taskConst) 7 ;; 08
  115. :: dataStack 2        (=taskConst) 8 ;; 08
  116. :: contextStack 2    (=taskConst) 9 ;; 08
  117.  
  118. :: trampoline 2      (=taskConst) 10 ;; 08 (( interactive execution area ))
  119.  
  120. :: textBuffer 2        (=taskConst) 11 ;; 08
  121. :: textHead 2        (=taskConst) 12 ;; 08
  122. :: textTail 2        (=taskConst) 13 ;; 08
  123. :: eof 2            (=taskConst) 14 ;; 0 (( xxx referred to directly in 'raiseEof' ))
  124.  
  125. :: infiles 2        (=taskConst) 15 ;; 08
  126. :: outfiles 2         (=taskConst) 16 ;; 08
  127. :: infile' 2        (=taskConst) 17 ;; 08
  128. :: outfile' 2        (=taskConst) 18 ;; 08
  129. :: infile 2            (=taskConst) 19 ;; 08
  130. :: outfile 2        (=taskConst) 20 ;; 08
  131. :: errfile 2        (=taskConst) 21 ;; 08
  132.  
  133. :: window 2            (=taskVar) 22 ;; 08    (( the output window of the task ))
  134. :: path 2            (=taskVar) 23 ;; 08 (( not in use in the current version ))
  135. :: assigning 2         (=taskVar) 24 ;; 08 (( to-variable assignment counter ))
  136.  
  137. :: error 2            (=taskVector) 25 ;; 0 (( vectored error routine ))
  138.  
  139. :: user' 2            (=taskVar) 26 ;; 08 (( the number of task variables ))
  140. :: compilation 2     (=taskVar) 27 ;; 08 (( current definition ))
  141. :: target 2             (=taskVar) 28 ;; 08 (( the name of -"- ))
  142. :: latest 2             (=taskVar) 29 ;; 08 (( latest defined name ))
  143. :: frameSize 2        (=taskVar) 30 ;; 08    (( number of temporary variables ))
  144.  
  145. :: whoToModify 2    (=taskVar) 31 ;; 0
  146. :: controls 2        (=taskVar) 32 ;; 08
  147. :: warnings 2        (=taskVar) 33 ;; 0
  148.  
  149. :: tram' 2            (=taskVar) 34 ;; 08 (( execution area offset ))
  150. :: comp' 2            (=taskVar) 35 ;; 08 (( compilation area offset ))
  151.  
  152. :: text' 2            (=taskVar) 36 ;; 08
  153. :: input 2            (=taskVar) 37 ;; 08
  154.  
  155.  
  156. (( Default stack sizes. yyy Note: the offset 6 below is ))
  157. (( non-portable and depends on DATAOFFSET + UNDERFLOWRESERVE ))
  158. :: sp# 7            dataStack object'size @ (lit) 6 - exit ;; 0     (( data stack size ))
  159. :: rp# 7            returnStack object'size @ (lit) 6 - exit ;; 0    (( return stack size )) 
  160. :: cp# 7            contextStack object'size @ (lit) 6 - exit ;; 0     (( context stack size ))
  161.  
  162.  
  163. (( Basic input/output extensions ))
  164. (( To allow multitasking, Kevo's I/O primitives operate on a character at  ))
  165. (( a time basis. In mainframe environment, this obviously consumes more    ))
  166. (( processor time. However, within the Kevo system processor time        ))
  167. (( utilization is pretty efficient. Furthermore, this solution is fully    ))
  168. (( portable, which has been one of the main objectives in designing Kevo.  ))
  169.  
  170. (( Macintosh Kevo uses a slightly different (event-driven) I/O scheme, ))
  171. (( so many of these definitions have been commented out. ))
  172.  
  173. :: "bs" 2     (=sharedConst) 8 ;; 0
  174. :: "tab" 2     (=sharedConst) 9 ;; 0
  175. :: "lf" 2    (=sharedConst) 10 ;; 0
  176. :: "cr" 2     (=sharedConst) 13 ;; 0
  177. :: "bl" 2    (=sharedConst) 32 ;; 0
  178. :: "del" 2     (=sharedConst) 127 ;; 0
  179.  
  180. :: tab 3    "tab" emit exit ;; 0
  181. (( :: cr 3        "cr"  emit exit ;; 0 ))
  182. :: space 3    "bl"  emit exit ;; 0
  183.  
  184. (( :: spaces 7    one (do) 4 space (loop) -2 exit ;; 0 ))
  185. (( :: type 12     dup b@ (if) 7 dup b@ emit 1+ (branch) -9 drop exit ;; 0 ))
  186.  
  187. :: ltype 9     >r count r> swap - swap type spaces exit ;; 0
  188. :: rtype 8     >r count r> swap - spaces type exit ;; 0
  189.  
  190. :: key 9    key? eof (if) 2 exit ?dup (if) -7 exit ;; 0
  191.  
  192. :: stdInput? 3    infile' 0= exit ;; 08
  193. :: (delText) 6    dup 0> (if) 2 1- exit ;; 08
  194. (( :: (delText) 12 dup 0> (if) 8 1- "bs" emit "bl" emit "bs" emit exit ;; 08 ))
  195. :: (addText) 8  over (lit) 5 pick + b! 1+ exit ;; 08
  196. :: (cutText) 4     nip + boff exit ;; 08
  197. :: expect 39     zero 
  198.                 2dup <=
  199.                     (if) 3 (cutText) exit 
  200.                     key dup "cr" <> over "lf" <> and eof not and 
  201.                 (if) 17 
  202.                        dup "bs" = over "del" = or 
  203.                     (if) 5 drop (delText) (branch) 2
  204. ((                   stdInput? (if) 3 dup emit ))
  205.                     (addText) 
  206.                 (branch) -34
  207. ((                "cr" = stdInput? and (if) 2 cr )) drop
  208.                 (cutText) exit ;; 0
  209.  
  210.  
  211. (( Error messages ))
  212. :: msg$dEmpty 5      errorTo ^^ -- Data stack empty^^ type exit ;; 08
  213. :: msg$dFull 5      errorTo ^^ -- Data stack full^^ type exit ;; 08
  214. :: msg$rEmpty 5      errorTo ^^ -- Return stack empty^^ type exit ;; 08
  215. :: msg$rFull 5      errorTo ^^ -- Return stack full^^ type exit ;; 08
  216. :: msg$cEmpty 5      errorTo ^^ -- Context stack empty^^ type exit ;; 08
  217. :: msg$cFull 5      errorTo ^^ -- Context stack full^^ type exit ;; 08
  218. :: msg$control 5  errorTo ^^ -- Illegal control structure^^ type exit ;; 08
  219. :: msg$what 5      errorTo ^^ -- ???^^ type exit ;; 08
  220. :: msg$"what 9      errorTo ^^ -- ??? --> ("^^ type type ^^ ")^^ type exit ;; 08
  221. :: msg$execOnly 5 errorTo ^^ -- Outside of definitions only^^ type exit ;; 08
  222. :: msg$compOnly 5 errorTo ^^ -- Within definitions only^^ type exit ;; 08
  223. :: msg$notObj 5   errorTo ^^ -- Given parameter is not an object^^ type exit ;; 08
  224. :: msg$noDot 5       errorTo ^^ -- Message syntax error^^ type exit ;; 08
  225. :: msg$notImpl 5  errorTo ^^ -- Binding error (property not implemented)^^ type exit ;; 08
  226. :: msg$notAvail 5 errorTo ^^ -- Binding error (property not available)^^ type exit ;; 08
  227. :: msg$unimpl 5      errorTo ^^ -- Unimplemented language feature^^ type exit ;; 08
  228.  
  229. :: ensureStruct 6    <> (if) 3 msg$control error exit ;; 08
  230. :: notImplemented 3 msg$notImpl error exit ;; 0
  231. :: notAvailable 3     msg$notAvail error exit ;; 0
  232. :: inRange 9        between not (if) 5 ^^ -- Out of range^^ type error exit ;; 0 
  233.  
  234. (( Execution state manipulation ))
  235.  
  236. (( Kevo compiler has two states: execution and compilation. In the compilation ))
  237. (( state the given definitions will be stored permanently to a dictionary ))
  238. (( (name space). In the execution mode, the compiled code will be executed ))
  239. (( and disposed of right after the compilation (in trampoline) ))
  240.  
  241. :: >compile 5    compilation @ target ! exit ;; 0
  242. :: >execute 4    trampoline target ! exit ;; 0
  243. :: executing 5    target @ trampoline = exit ;; 0
  244. :: compiling 5    target @ trampoline <> exit ;; 0
  245. :: mustCompile 6    executing (if) 3 msg$compOnly error exit ;; 0
  246. :: mustExecute 6    compiling (if) 3 msg$execOnly error exit ;; 0
  247.  
  248.  
  249. (( Pseudovariables ))
  250.  
  251. (( xxx0 implies the _beginning_ of something ))
  252. (( xxx' implies the current _pointer_ to something ))
  253. (( xxx# implies the current _size_ of something ))
  254.  
  255. :: user0 4        up @ object>store exit ;; 08 
  256. :: user# 5        up @ object'size @ exit ;; 08 
  257. :: text0 3        textBuffer object>store exit ;; 08
  258. :: text# 5        textBuffer object'size @ cell* exit ;; 08  
  259. :: infile0 3     infiles object>store exit ;; 08
  260. :: infile# 4    infiles object'size @ exit ;; 08
  261. :: outfile0 3    outfiles object>store exit ;; 08
  262. :: outfile# 4    outfiles object'size @ exit ;; 08
  263. :: tram0 3        trampoline object>store exit ;; 08
  264. :: tram# 4        trampoline object'size @ exit ;; 08
  265. :: comp0 4        compilation @ object>store exit ;; 08
  266. :: comp# 5        compilation @ object'size @ exit ;; 08
  267. :: here0 4        target @ object>store exit ;; 08
  268. :: here' 8        compiling (if) 4 comp' (branch) 2 tram' exit ;; 08
  269. :: here# 5        target @ object'size @ exit ;; 08
  270. :: here 3        here' @ exit ;; 0
  271.  
  272.  
  273. (( Compilation primitives ))
  274.  
  275. (( These differ considerably from the seemingly similar definitions in Forth ))
  276. (( Our language supports dynamic memory management, so the allotted memory must ))
  277. (( be able to expand and shrink automatically ))
  278.  
  279. :: allot 17        align dup here + cell/ here# - 1+ zero max cell* 
  280.                 target @ <expand> here' +! exit ;; 0
  281. :: , 7            here0 here + ! cell allot exit ;; 0
  282. :: compile, 7    here0 here + ! cell allot exit ;; 0 (( defined for portability ))
  283. :: override, 6    here0 here cell- + ! exit ;; 0
  284. :: literal, 5    (lit) (lit) compile, , exit ;; 0
  285. :: "literal, 6    (lit) ("lit) compile, <buildString> , exit ;; 0
  286. :: (compile) 7    r> dup @ compile, cell+ >r exit ;; 08
  287.  
  288.  
  289. (( Execution area (trampoline) memory management ))
  290. :: tramAllot 17    align dup tram' @ + cell/ tram# - 1+ zero max cell* 
  291.                 trampoline <expand> tram' +! exit ;; 08
  292. :: tram, 8        tram0 tram' @ + ! cell tramAllot exit ;; 08
  293.  
  294.  
  295. (( Task data area management ))
  296. (( These operations are not really intended for high-level use ))
  297. (( note that userAllot parameters are cells rather than bytes ))
  298. :: userAllot 16    dup user' @ + user# - 1+ zero max cell* 
  299.                 up @ <expand> user' +! exit ;; 0
  300. :: user, 9        user0 user' @ cell* + ! one userAllot exit ;; 0
  301.  
  302.  
  303. (( Code execution primitives ))
  304. (( These are something which you cannot find in normal Forth systems. ))
  305. (( They allow control structures to operate interactively, which is ))
  306. (( a major advantage over conventional implementations. ))
  307.  
  308. (( Note that after a piece of interactively written and compile code has ))
  309. (( been executed it will be automatically deallocated ))
  310. :: cycle 8    tram# <buildStore> trampoline object'store ! tram' off exit ;; 08
  311.  
  312. :: go 16    tram' @ (if) 12
  313.                 (lit) (lit) tram,  
  314.                 tram0 tram,          (( set the code to dispose of itself ))
  315.                 (lit) freeExit tram, 
  316.                 tram0 cycle <executeStore> 
  317.             exit ;; 08
  318.  
  319.             (( Unix-like pipe: the code left of | will be compiled and executed ))
  320.             (( as if it were a separate line ))
  321. :: (|) 8    controls @ (if) 3 msg$control error go exit ;; 08
  322. :: | 9        compiling (if) 5 (compile) (|) (branch) 2 (|) exit ;; 80
  323.  
  324.  
  325. (( Message sending primitives ))
  326. :: top 1             exit ;; 80
  327. :: send 3             >send self>drop exit ;; 08
  328. :: resend 7            mustCompile latest @ literal, (compile) >resend exit ;; 80
  329.  
  330.  
  331. (( Command input stream management ))
  332.  
  333. (( Again some of these have been commented, because the Mac implementation ))
  334. (( uses a slightly different I/O strategy ))
  335.  
  336. :: prepareText 11 text0 count + 1+ boff text0 text' ! input off exit ;; 08
  337.  
  338. (( :: query 6    text0 text# 2- expect prepareText exit ;; 0 ))
  339. :: query 8        textAvailable (if) -2 text' ! input off exit ;; 0
  340.  
  341. :: (parse) 27    text' @ b@ 
  342.                 (if) 18 text' @ skipWhite dup dup input ! scanWhite dup 
  343.                 zero swap b! 1+ text' ! (branch) 5
  344.                 input off text' @ 
  345.                 exit ;; 08
  346.  
  347. :: PARSE 10        compiling (if) 5 (compile) (parse) (branch) 3 
  348.                 (parse) "literal, exit ;; 80 
  349.  
  350. :: (word) 28    text' @ b@ 
  351.                 (if) 18 text' @ dup dup input ! rot scan dup zero swap b! 
  352.                 1+ text' ! (branch) 6
  353.                 drop input off text' @ exit ;; 08
  354.  
  355. :: WORD 11        compiling (if) 5 (compile) (word) (branch) 4 
  356.                 (|) (word) "literal, exit ;; 80 
  357.  
  358. :: ( 5            (lit) 41 (word) drop exit ;; 80
  359. :: \ 4            zero (word) drop exit ;; 80
  360.  
  361. :: " 5            (lit) 34 (word) "literal, exit ;; 80
  362. :: ." 4            " (compile) type exit ;; 80
  363. :: ^ 5            (lit) 94 (word) "literal, exit ;; 80
  364. :: .^ 4            ^ (compile) type exit ;; 80
  365.  
  366. :: checkStacks 40
  367.          depth 0<    (if) 3 msg$dEmpty error
  368.          depth sp# > (if) 3 msg$dFull  error
  369.         rdepth 0<    (if) 3 msg$rEmpty error
  370.         rdepth rp# > (if) 3 msg$rFull  error
  371.         cdepth 0<    (if) 3 msg$cEmpty error
  372.         cdepth cp# > (if) 3 msg$cFull  error
  373.         exit ;; 0
  374.  
  375. :: resetContext 12    cdepth 0> (if) 5 self resetCp >self exit 
  376.                     resetCp Root >self exit ;; 0
  377.  
  378.  
  379. (( Threaded code compiler ))
  380. :: encode 2        (=sharedVector) ooEncode ;; 08
  381. :: (encode) 24    dup search
  382.                 (if) 12 nip dup immediate? 
  383.                     (if) 4 name>object execute exit 
  384.                     name>object compile, exit 
  385.                 number (if) 4 literal, (branch) 3
  386.                 msg$what error
  387.                 exit ;; 08
  388.  
  389.  
  390. (( Dot expression (message) parser ))
  391. :: noDotsAtAll 6    (lit) 46 scan b@ 0= exit ;; 08
  392. :: dotInBeginning 5 b@ (lit) 46 = exit ;; 08
  393. :: dotInEnd 8         count + 1- b@ (lit) 46 = exit ;; 08
  394. :: dotExpression 24 dup noDotsAtAll (if) 3 false exit 
  395.                     dup dotInBeginning (if) 3 false exit 
  396.                     dup dotInEnd (if) 3 false exit 
  397.                     dup (lit) 46 enclose true exit ;; 08
  398. :: message, 4         "literal, (compile) send exit ;; 08
  399. :: skipDot 4         count + 1+ exit ;; 08
  400. :: innerMessages 9     skipDot dotExpression 
  401.                     (if) 5 dup message, 
  402.                     (branch) -7 exit ;; 08
  403. :: lastMessage 12     dup noDotsAtAll 
  404.                     (if) 5 assignment? message, 
  405.                     (branch) 4 drop msg$noDot error exit ;; 08
  406. :: encodeMessages 10 dup (encode) executing (if) 3 (compile) mustBeObject 
  407.                     innerMessages lastMessage exit ;; 08
  408.  
  409. :: ooEncode 9         dotExpression 
  410.                     (if) 4 encodeMessages (branch) 3 
  411.                     assignment? (encode) exit ;; 0
  412.  
  413.  
  414. (( Command interface ))
  415. :: interpret 17    (parse) dup b@ (if) 4 encode (branch) -7 
  416.                 drop controls @ 0= (if) 2 go checkStacks exit ;; 0
  417.  
  418. :: .ok 5        ^^  ok^^ type cr exit ;; 0
  419.  
  420. :: prompt 11    controls @ 0= stdInput? and 
  421.                 (if) 4 popOutfile .s .ok 
  422.                 exit ;; 0
  423.  
  424. (( This is the big kabloona: the Kevo kernel command shell ))
  425. :: shell 10        controls off resetContext cycle >execute 
  426.                 prompt query interpret (branch) -4 ;; 0
  427.  
  428.  
  429. (( Error handling ))
  430. :: resetFiles 3 resetInfiles resetOutfiles exit ;; 0
  431.  
  432. :: abort 4        resetSp resetFiles reboot shell ;; 0
  433.  
  434.                 (( the main error handler; resets stacks, files, textbuffers etc. ))
  435.                 (( and prints the end part of the error message ))
  436. :: (error) 36    resetSp input @ ?dup
  437.                 (if) 21 ^^  --> ("^^ type type ^^ ")^^ type 
  438.                  compiling (if) 9 
  439.                      ^^  in: ^^ type latest @ name'name @ type (branch) 4 
  440.                 ^^  --> (runtime)^^ type 
  441.                 cr resetFiles eraseText input off 
  442.                 reboot shell ;; 08
  443.  
  444.                 (( the object-oriented error handler ))
  445.                 (( prints context stack trace when its depth >1 ))
  446. :: oopError 19    cdepth one > 
  447.                 (if) 12 ^^ traceBack^^ self searchThis 
  448.                     (if) 3 name>object execute
  449.                     self>drop 
  450.                 (branch) -15 
  451.                 resetContext (error) exit ;; 0
  452.  
  453.                 (( don't remove this; needed internally by the browser ))
  454. :: brError 5    bell bell |> oopError exit ;; 08
  455.  
  456.  
  457. (( Name space management ))
  458.                 (( return the name field address given a string ))
  459. :: find 9        dup search 
  460.                 (if) 3 nip exit 
  461.                 msg$"what error
  462.                 exit ;; 0 
  463.  
  464.                 (( return the execution address given a string ))
  465. :: tick 3        find name>object exit ;; 0
  466.  
  467.                 (( check if a word can be found in the name space ))
  468. :: DEFINED 12    (parse) search 
  469.                 (if) 6 drop (compile) true (branch) 3
  470.                 (compile) false 
  471.                 exit ;; 80
  472.         
  473.                 (( high-level versions of 'find' and 'tick' ))
  474. :: FIND 4        (parse) find literal, exit ;; 80
  475. :: ' 4            (parse) tick literal, exit ;; 80
  476.  
  477. (( The following ops have been implemented for backward compatibility. ))
  478. (( The same effect can be achieved more reliably with module operations. ))
  479. :: forget 3        find <deleteName> exit ;; 0
  480.                 (( can create garbage which should be collected ))
  481. :: FORGET 5        (parse) "literal, (compile) forget exit ;; 80
  482.  
  483. :: forgetRest 14 find name'succ @ ?dup 
  484.                  (if) 8 
  485.                     dup name'succ @ swap <deleteName> 
  486.                 (branch) -9 
  487.                 exit ;; 0
  488. :: empty 4        ^^ boot^^ forgetRest exit ;; 0
  489.  
  490.  
  491. (( Compilation auxiliaries ))
  492. :: ASCII 4        (parse) b@ literal, exit ;; 80
  493. :: "interpret 7 count 1+ text0 move prepareText interpret exit ;; 0
  494.  
  495. :: COMPILE 6    (parse) tick (compile) (compile) , exit ;; 80
  496. :: NOW 4         (parse) tick execute exit ;; 80
  497. :: LATER 4         (parse) tick compile, exit ;; 80
  498.  
  499. :: (=>) 4        object>store cell+ ! exit ;; 08
  500. :: => 4            ' (compile) (=>) exit ;; 80
  501. :: (tick&) 3    object>store cell+ exit ;; 08
  502. :: '& 4            ' (compile) (tick&) exit ;; 80
  503.  
  504.                 (( access another task's data area ))
  505. :: his 5        cell* swap object>store + exit ;; 08
  506. :: HIS 9        (parse) tick object>store cell+ @ literal, 
  507.                 (compile) his exit ;; 80
  508.  
  509.                 (( access our own task data area ))
  510. :: my 4            cell* user0 + exit ;; 08
  511. :: MY 9            (parse) tick object>store cell+ @ literal, 
  512.                 (compile) my exit ;; 80
  513.  
  514. :: -> 3             assigning on exit ;; 80
  515. :: assignment? 9     assigning @ (if) 5 (compile) (->) assigning off exit ;; 08
  516.  
  517.  
  518. (( System extension operations ))
  519. :: immediate 6    "immediate" latest @ name'flags toggle   exit ;; 0
  520. :: hidden 6        "hidden"    latest @ name'flags toggle   exit ;; 0
  521. :: smudge 6        "smudge"    latest @ name'flags toggle   exit ;; 0
  522. :: unsmudge 6    "smudge"    latest @ name'flags untoggle exit ;; 0
  523.  
  524. :: default# 2    (=sharedConst) 2 ;; 08    (( default size of definitions ))
  525.  
  526.                 (( warn the user about possible overriding of names ))
  527. :: warn 25        warnings @
  528.                 (if) 20 
  529.                     ^^ Defining ^^ type dup type
  530.                     search
  531.                     (if) 7 drop ^^  (previous definition overridden).^^ type cr exit
  532.                     (lit) 46 emit cr exit
  533.                 drop exit ;; 08
  534.  
  535.                 (( warn the user about redefinitions ))
  536. :: rewarn 15    warnings @ 
  537.                 (if) 10 
  538.                     ^^ Redefining ^^ type type
  539.                     (lit) 46 emit cr exit
  540.                 drop exit ;; 08
  541.  
  542. :: (create) 12    default# <buildObject> dup compilation ! 
  543.                 latest @ name'object ! 
  544.                 comp' off exit ;; 0
  545.  
  546.                 (( create/override an entry in a name space ))
  547. :: create 8        dup warn 
  548.                 self <buildName> latest !
  549.                 (create) exit ;; 0
  550.                  
  551. :: (replace) 23 dup latest ! dup name'flags off
  552.                 name>object compilation ! 
  553.                 (( <freeStore> can crash the system if the code is run by other tasks ))
  554.                 (( compilation @ <freeStore> ))
  555.                 default# <buildStore> compilation @ object'store ! 
  556.                 default# compilation @ object'size ! comp' off exit ;; 08
  557.  
  558.                 (( given a string, redefine the corresponding property ))
  559.                 (( this operation changes the behavior of all the objects ))
  560.                 (( who refer to the property ))
  561. :: replace 6    dup find swap rewarn (replace) exit ;; 0
  562.  
  563. :: (recreate) 12 dup latest ! dup name'flags off 
  564.                 name>object (create) latest @ <recompile> exit ;; 08
  565.  
  566.                 (( given a string, redefine the corresponding property ))
  567.                 (( this operation preserves the behavior of other objects ))
  568.                 (( all the references to the property in this object (family) ))
  569.                 (( are rebound using primitive '<recompile>' )) 
  570. :: recreate 6    dup find swap rewarn (recreate) exit ;; 0
  571.  
  572. :: (:) 6        >compile smudge controls ++ ":" exit ;; 08
  573.  
  574.                 (( don't remove this; needed internally by browser's method redefiner ))
  575. :: bredef 31    mustExecute
  576.                 dup "thisOnly" = (if) 10 drop self <derive> dup self <rePair> (recreate) (:) exit
  577.                 dup "wholeFamily" = (if) 5 drop (recreate) (:) exit
  578.                 "derivatives"     = (if) 3      (replace) (:) exit ;; 08
  579.  
  580.                 (( access words to the storage part of the latest definition ))
  581. :: does, 3        comp0 ! exit ;; 0
  582. :: with, 4        comp0 cell+ ! exit ;; 0
  583.  
  584.                 (( this word is implemented for Forth-compatibility ))
  585. :: CREATE 13    compiling (if) 6 (compile) (parse) immediate (branch) 3 
  586.                 (parse) "literal, 
  587.                 (compile) create exit ;; 80
  588.  
  589. :: : 5            mustExecute (parse) create (:) exit ;; 80
  590.  
  591. :: ; 11            mustCompile controls -- ":" ensureStruct 
  592.                 unsmudge (lit) exit compile, 
  593.                 (( compilation @ <optimize> )) >execute exit ;; 80 
  594.  
  595. :: recurse 5    mustCompile compilation @ compile, exit ;; 80
  596. :: myself 8        (compile) (branch) zero here - cell/ , exit ;; 80
  597.  
  598.  
  599. (( Multitasker extensions ))
  600. :: stop 7    resetFiles up @ suspend yield reboot shell ;; 0
  601. (( :: (bgError) 9    resetSp ^^  --> (background task)^^ type cr
  602.         resetFiles stop reboot shell ;; 08 ))
  603.  
  604.             (( the following six operations are preserved for backwards ))
  605.             (( compatibility with earlier versions of Kevo ))
  606.             (( background task creation (no window) ))
  607. :: bgtask 7    create (lit) (=sharedConst) does, <buildBGTask> with, exit ;; 0
  608. :: BGTASK 5    (parse) "literal, (compile) bgtask exit ;; 80
  609.  
  610.             (( graphics task creation (no Mac TextEdit services ) ))
  611. :: grtask 7    create (lit) (=sharedConst) does, <buildGRTask> with, exit ;; 0
  612. :: GRTASK 5    (parse) "literal, (compile) grtask exit ;; 80
  613.  
  614.             (( full task creation (window with TextEdit) ))
  615. :: task 7    create (lit) (=sharedConst) does, <buildTETask> with, exit ;; 0
  616. :: TASK 5    (parse) "literal, (compile) task exit ;; 80
  617.  
  618.  
  619. (( Unix-like background tasks ))
  620.             (( background tasks kill themselves automatically ))
  621.             (( files are also closed ))
  622. :: killExit 6    <free> resetFiles up @ <killTask> exit ;; 08
  623.  
  624.             (( pipe to background (see '(|)' above) ))
  625. :: (BG|) 17    controls @ 
  626.             (if) 3 msg$control error 
  627.             (lit) (lit) tram, 
  628.             tram0 tram,
  629.             (lit) killExit tram, 
  630.             tram0 cycle exit ;; 08
  631.  
  632.             (( The code for background tasks ))
  633.             (( The actual code is given as a parameter in the data stack ))
  634. :: (runBG) 2    <executeStore> exit ;; 08     
  635.  
  636.             (( Define an operation to execute on background ))
  637. :: BG 13     mustExecute (BG|) <buildBGTask> >r
  638.             (lit) (runBG) r@ does 
  639.             r@ >taskData 
  640.             r> activate exit ;; 80
  641.  
  642.  
  643. (( Debugger extensions ))
  644. (( Note that debugging can be used only on non-primitive operations ))
  645.             (( set a breakpoint at a certain operation ))
  646. :: debug 23    dup object'size @ 1- cell* swap object>store + dup @ 
  647.             (lit) exit = (if) 7 (lit) debugExit swap ! (branch) 2 drop exit ;; 0
  648.  
  649.             (( remove a breakpoint from an operation ))
  650. :: unbug 23    dup object'size @ 1- cell* swap object>store + dup @ 
  651.             (lit) debugExit = (if) 7 (lit) exit swap ! (branch) 2 drop
  652.             exit ;; 0
  653.  
  654.             (( shorthand for resume ))
  655. :: r 2        resume exit ;; 0
  656.  
  657.  
  658. (( Variable, constant, vector and context declaration ))
  659.  
  660. :: sharedVar 5    create (lit) (=sharedVar) does, exit ;; 0
  661. :: taskVar 10    create (lit) (=taskVar) does, user' @ with, zero user, exit ;; 0
  662.  
  663. :: sharedConst 6 create (lit) (=sharedConst) does, with, exit ;; 0
  664. :: taskConst 9      create (lit) (=taskConst) does, user' @ with, user, exit ;; 0
  665.  
  666. :: sharedVector 6 create (lit) (=sharedVector) does, with, exit ;; 0
  667. :: taskVector 9   create (lit) (=taskVector) does, user' @ with, user, exit ;; 0
  668.  
  669. (( The following three definitions are added for Forth-compatibility ))
  670. :: VARIABLE 5    (parse) "literal, (compile) sharedVar exit ;; 80
  671. :: CONSTANT 5   (parse) "literal, (compile) sharedConst exit ;; 80
  672. :: DEFER 5        (parse) "literal, (compile) sharedVector exit ;; 80
  673.  
  674. (( Semaphore operations for monitor implementation ))
  675. (( These operations can be associated with any REF or VAR ))
  676. :: (wait) 22    ({) (->) <temp> temp: 1 execute 0= (if) 4 yield (branch) -8
  677.                 temp: 1 execute 1- temp: 1 (->) execute (}) exit ;; 08
  678. :: (signal) 7    dup execute 1+ swap (->) execute exit ;; 08
  679. :: WAIT 4        ' (compile) (wait) exit ;; 80
  680. :: SIGNAL 4        ' (compile) (signal) exit ;; 80
  681.  
  682. (( Context creation and maneuvering ))
  683. :: mkdir 7         create (lit) (=REF) does, <mkdir> with, exit ;; 0
  684. :: MKDIR 5         (parse) "literal, (compile) mkdir exit ;; 80
  685.  
  686. :: context 9     create (lit) (=context) does, compilation @ <buildContext> with, exit ;; 0
  687. :: CONTEXT 5     (parse) "literal, (compile) context exit ;; 80
  688.  
  689. :: mustBeObject 9 dup hasContext not (if) 4 drop msg$notObj error exit ;; 0
  690.  
  691. :: CD 4            mustBeObject >self resetContext exit ;; 0
  692.  
  693. :: cd 6            CD ^^ Context is now: ^^ type .cs exit ;; 0
  694. :: pwd 2        .cs exit ;; 0
  695.  
  696. :: home    3        Root CD exit ;; 0
  697.  
  698.  
  699. (( Object definition high-level words ))
  700. (( ---------------------------------- ))
  701.  
  702. (( property addition module operations ))
  703.                 (( Note: ADDS/ADDS* has a small shortcut: ))
  704.                 (( 'whoToModify' information should be stored ))
  705.                 (( in a stack so as to allow unlimited nesting ))
  706.                 (( of ADDS...ENDADDS; structures xxx ))
  707. :: (ADDS) 7        dup <derive> >self "thisOnly" whoToModify ! exit ;; 08
  708. :: ADDS 3         (compile) (ADDS) exit ;; 80
  709.  
  710. :: (ADDS*) 5    >self "wholeFamily" whoToModify ! exit ;; 08
  711. :: ADDS* 3         (compile) (ADDS*) exit ;; 80
  712.  
  713. :: ADDS** 3        msg$unimpl error exit ;; 80
  714.  
  715. :: (REF) 5        create (lit) (=REF) does, exit ;; 08
  716. :: REF 5         (parse) "literal, (compile) (REF) exit ;; 80
  717.  
  718. :: (VAR) 12        create (lit) (=VAR) does, 
  719.                 self object'size @ with, 
  720.                 one self <expandFamily> exit ;; 08
  721. :: VAR 5         (parse) "literal, (compile) (VAR) exit ;; 80
  722.  
  723. :: SHAREDVAR 2    REF exit ;; 80
  724. :: CONST 5        (parse) "literal, (compile) sharedConst exit ;; 80
  725. :: METHOD 2        : exit ;; 80
  726.  
  727. :: (ENDADDS) 15    cdepth one > 
  728.                 (if) 8 
  729.                     whoToModify @ self <reorganize>
  730.                     self>drop (branch) 3
  731.                 msg$control error
  732.                 exit ;; 08
  733. :: ENDADDS; 3    (compile) (ENDADDS) exit ;; 80
  734.  
  735.  
  736. (( redefinition module operations ))
  737. (( Note: these operations do not preserve the current context ))
  738. :: REDEFINE    8    (|) dup <derive> CD (parse) recreate (:) exit ;; 80
  739. :: REDEFINE* 6    (|) CD (parse) recreate (:) exit ;; 80
  740. :: REDEFINE** 6 (|) CD (parse) replace (:) exit ;; 80
  741.  
  742.  
  743. (( renaming module operations ))
  744. :: rename 13    rot dup <derive> >self swap find swap <renameName> 
  745.                 "thisOnly" self <reorganize> self>drop exit ;; 0
  746. :: RENAME 5        (parse) "literal, (compile) rename exit ;; 80
  747.  
  748. :: rename* 8    rot >self <renameName> "wholeFamily" self <reorganize> self>drop exit ;; 0
  749. :: RENAME* 6    FIND (parse) "literal, (compile) rename* exit ;; 80
  750.  
  751. :: RENAME** 3    msg$unimpl error exit ;; 80
  752.  
  753.  
  754. (( removal module operations ))
  755. :: remove 11    swap dup <derive> >self find <deleteName> 
  756.                 "thisOnly" self <reorganize> self>drop exit ;; 0
  757. :: REMOVE 5        (parse) "literal, (compile) remove exit ;; 80
  758.  
  759. :: remove* 8    swap >self <deleteName> "wholeFamily" self <reorganize> self>drop exit ;; 0        
  760. :: REMOVE* 4    FIND (compile) remove* exit ;; 80
  761.  
  762. :: REMOVE** 3    msg$unimpl error exit ;; 80
  763.  
  764.  
  765. (( encapsulation module operations ))
  766. :: hide 14        swap dup <derive> >self "hidden" swap find name'flags toggle 
  767.                 "thisOnly" self <reorganize> self>drop exit ;; 0
  768. :: HIDE 5        (parse) "literal, (compile) hide exit ;; 80
  769.  
  770. :: hide* 8        swap >self "hidden" swap name'flags toggle self>drop exit ;; 0
  771. :: HIDE* 4        FIND (compile) hide* exit ;; 80
  772.  
  773. :: HIDE** 3        msg$unimpl error exit ;; 80
  774.  
  775. :: show 14        swap dup <derive> >self "hidden" swap find name'flags untoggle 
  776.                 "thisOnly" self <reorganize> self>drop exit ;; 0
  777. :: SHOW 5        (parse) "literal, (compile) show exit ;; 80
  778.  
  779. :: show* 8        swap >self "hidden" swap name'flags untoggle self>drop exit ;; 0
  780. :: SHOW* 4        FIND (compile) show* exit ;; 80
  781.  
  782. :: SHOW** 3        msg$unimpl error exit ;; 80
  783. (( ---------------------------------- ))
  784.  
  785.  
  786. (( Control structure branch offset calculation ))
  787. :: mark> 4        here zero , exit ;; 08
  788. :: resolve> 9    here over - cell/ swap here0 + ! exit ;; 08
  789. :: mark< 2        here exit ;; 08
  790. :: resolve< 5    here - cell/ , exit ;; 08
  791.  
  792.  
  793. (( Arbitrary constants for control structure syntax checking ))
  794. :: "if" 2        (=sharedConst) 11111 ;; 08
  795. :: "begin" 2    (=sharedConst) 22222 ;; 08
  796. :: "while" 2    (=sharedConst) 33333 ;; 08
  797. :: "do" 2        (=sharedConst) 44444 ;; 08
  798. :: "of" 2        (=sharedConst) 55555 ;; 08
  799. :: ":" 2        (=sharedConst) 66666 ;; 08
  800. :: "{}" 2        (=sharedConst) 77777 ;; 08
  801.  
  802.  
  803. (( Control structure high-level words ))
  804. :: IF 7        (compile) (if) mark> controls ++ "if" exit ;; 80
  805. :: ELSE 9    "if" ensureStruct
  806.             (compile) (branch) mark> swap resolve> "if" exit ;; 80
  807. :: THEN 6    "if" ensureStruct controls -- resolve> exit ;; 80
  808.  
  809. :: BEGIN 5    mark< controls ++ "begin" exit ;; 80
  810. :: AGAIN 8    "begin" ensureStruct controls -- 
  811.             (compile) (branch) resolve< exit ;; 80
  812. :: UNTIL 8    "begin" ensureStruct controls -- 
  813.             (compile) (if) resolve< exit ;; 80
  814. :: WHILE 7    "begin" ensureStruct
  815.             (compile) (if) mark> "while" exit ;; 80
  816. :: REPEAT 10 "while" ensureStruct controls -- 
  817.             (compile) (branch) swap resolve< resolve> exit ;; 80
  818.  
  819. :: DO 9        (compile) (do) mark> mark< controls ++ zero "do" exit ;; 80
  820. :: TIMES 4     (compile) one DO exit ;; 80
  821. :: MSECS 9    (compile) (msecsDo) mark> mark< controls ++ one "do" exit ;; 80
  822. :: LOOP 15    "do" ensureStruct controls -- 
  823.             (if) 5 (compile) (msecsLoop) (branch) 3 (compile) (loop) 
  824.             resolve< resolve> exit ;; 80
  825. :: +LOOP 10    "do" ensureStruct controls -- 
  826.             drop (compile) (+loop) resolve< resolve> exit ;; 80
  827.  
  828. :: CASE 6        (compile) dup zero controls ++ exit ;; 80
  829. :: OF 7            (compile) (if) mark> (compile) drop "of" exit ;; 80
  830. :: ENDOF 12        "of" ensureStruct
  831.                 (compile) (branch) mark> swap resolve> (compile) dup swap 1+ exit ;; 80
  832. :: ELSEOF 5        (lit) true override, OF exit ;; 80
  833. :: ENDCASE 12    controls -- (lit) drop override, 
  834.                 one (do) 4 resolve> (loop) -2 exit ;; 80
  835.  
  836.  
  837. (( Temporary variables (blocks) ))
  838. :: (=template) 6 (compile) temp: r> @ , exit ;; 08
  839.  
  840.                 (( Build a compile-time temporary variable ))
  841. :: TEMP 29        (parse) self <buildName> 
  842.                 "immediate" over name'flags toggle
  843.                 default# <buildObject> dup rot name'object !
  844.                 (lit) (=template) over object>store !
  845.                 frameSize @ swap object>store cell+ !
  846.                 frameSize ++ (compile) <temp> exit ;; 80
  847.                 
  848. :: forgetTemp 17 dup name>object object>store @ (lit) (=template) =
  849.                 (if) 7 dup name>object dup object>store <free> <free>
  850.                 <deleteName> exit ;; 08
  851.  
  852.                 (( delete the compile-time temporary variable info ))
  853. :: forgetTemps 13 name'succ @ 
  854.                 ?dup (if) 8 dup name'succ @ swap forgetTemp (branch) -9 
  855.                 exit ;; 08
  856.                 
  857. :: { 9            (compile) ({) one frameSize !
  858.                 controls ++ "{}" exit ;; 80
  859. :: } 10            "{}" ensureStruct controls --
  860.                 (compile) (}) latest @ forgetTemps exit ;; 80
  861.  
  862.  
  863. (( File interface ))
  864.  
  865. (( Kevo supports very flexible I/O redirection. Each task can have basically an ))
  866. (( unlimited number of nested input and output files. The number of nested input ))
  867. (( files is limited by the size of return stack which does not grow automatically ))
  868. (( (can be changed manually using 'resizeReturnStack', though).
  869.  
  870.                 (( raise 'eof' using the ugly way )) 
  871. :: raiseEof 8    true up @ (lit) 14 his ! exit ;; 08    
  872. :: fileShell 6  query interpret eof (if) -4 exit ;; 08
  873. :: from 3        pushInfile fileShell exit ;; 0
  874. :: endFrom 3    popInfile raiseEof exit ;; 0
  875.  
  876. :: to 3            "write"  pushOutfile exit ;; 0
  877. :: >>to 3        "append" pushOutfile exit ;; 0
  878. :: endTo 2        popOutfile exit ;; 0
  879.  
  880. (( Block file auxiliaries ))
  881. (( Note: in current implementation, block files are not task-specific ))
  882. (( i.e., only one block file can be open at any time ))
  883. :: b/buf 3        (lit) 1024 exit ;; 0
  884. :: flush 3        save-buffers empty-buffers exit ;; 0
  885.  
  886.  
  887. (( User tools and utilities ))
  888.                 (( convert clock ticks to milliseconds and vice versa. ))
  889.                 (( in Mac, clock ticks occur every 1/60 second. ))
  890. :: ticks>msecs 7 (lit) 10 * (lit) 6 / exit ;; 0
  891. :: msecs>ticks 7 (lit) 6 * (lit) 10 / exit ;; 0
  892.  
  893.                 (( delay for n milliseconds ))
  894. :: msecs 6        (msecsDo) 4 yield (msecsLoop) -2 exit ;; 0
  895.  
  896.                 (( random number generator ))
  897. :: seed 2         (=sharedVar) 0 ;; 08
  898. :: randomize 7    clock (lit) 2147483647 * seed ! exit ;; 0
  899. :: random 12     seed @ (lit) 16807 * (lit) 2147483647 umod dup seed ! exit ;; 0
  900. :: rnd 8         over - 1+ random swap umod + exit ;; 0
  901.  
  902.                 (( execute host system commands. This does not work in Mac ))
  903. :: $ 7            mustExecute zero (word) "literal, (compile) system exit ;; 80
  904.  
  905. :: isPrintable 6     (lit) 32 (lit) 127 between exit ;; 0
  906.  
  907.                 (( memory hex & ascii dump ))
  908. :: dump 55         one (do) 51 
  909.                     dup h. ^^ : ^^ type 
  910.                     (lit) 15 (lit) 0 (do) 8 
  911.                         i over + b@ h. 
  912.                     (loop) -6 ^^ : ^^ type 
  913.                     (lit) 15 (lit) 0 (do) 18 
  914.                         i over + b@ dup 
  915.                         isPrintable (if) 4 emit (branch) 5 drop (lit) 95 emit 
  916.                     (loop) -16 cr 
  917.                     (lit) 16 + 
  918.                 (loop) -49 
  919.                 drop exit ;; 0
  920.  
  921.                 (( decompile a definition ))
  922. :: SEE 4        ' (compile) see exit ;; 80
  923.  
  924. :: (-) 8        ^^   ( ^^ type . ^^ )^^ type exit ;; 08
  925. :: mirror 35    ^^ Mirror of context: ^^ type .cs cr cr 
  926.                 self object>context context'first @
  927.                 zero swap
  928.                 ?dup
  929.                 (if) 19
  930.                     dup name'name @ type 
  931.                     swap 1+ dup (-) swap cr
  932.                     dup name>object see cr
  933.                     name'succ @
  934.                 (branch) -20 drop exit ;; 0
  935.  
  936. :: name. 6             name'name @ (lit) 19 rtype exit ;; 8
  937. :: ?cr 12             swap 1+ dup (lit) 4 mod 0= (if) 2 cr swap exit ;; 08
  938.  
  939.                     (( name space contents listing ))
  940. :: allnames 23         cr 
  941.                     object>context context'first @ 
  942.                     zero swap 
  943.                         ?dup 
  944.                     (if) 8 
  945.                         dup name. ?cr name'succ @ 
  946.                     (branch) -9 
  947.                     cr . ^^ names.^^ type cr exit ;; 0
  948.  
  949. :: allwords 3         self allnames exit ;; 0
  950.  
  951. :: succWords 35     zero zero rot 
  952.                     ?dup (if) 19 
  953.                         dup name'flags @ "hidden" and 0= 
  954.                         (if) 4 dup name. ?cr 
  955.                         rot 1+ -rot name'succ @ 
  956.                     (branch) -20 
  957.                     cr . ^^ names (^^ type . ^^ in total).^^ type cr exit ;; 0
  958.  
  959. :: names 6             cr object>context context'first @ succWords exit ;; 0
  960.  
  961. :: words 3             self names exit ;; 0
  962. (( :: mywords 7        ^^ boot^^ find name'succ @ succWords exit ;; 0 ))
  963.  
  964. :: prevWords 19        zero swap
  965.                         ?dup
  966.                     (if) 8
  967.                         dup name. ?cr name'prev @
  968.                     (branch) -9
  969.                     cr . ^^ names.^^ type cr exit ;; 0
  970.  
  971.                     (( list the words in the predecessor link order ))
  972.                     (( each thread separately ))
  973. :: .threads 14        #threads 1- zero 
  974.                     (do) 9 
  975.                         i self object>context context'thread @ prevWords 
  976.                     (loop) -7 exit ;; 0
  977.  
  978.  
  979. (( System startup ))
  980. :: hello 11            cr ^^ -- Kevo Kernel v0.9b6 --^^ type cr 
  981.                        ^^ -- (c) A. Taivalsaari 1993 --^^ type cr cr exit ;; 0
  982. :: demoInfo 5        ^^ Type 'demo' to load the demo programs.^^ type cr exit ;; 0
  983. :: demo 4            ^^ demo.kevo^^ from exit ;; 0
  984. :: SystemInit 15     randomize                 (( initialize random number seed ))
  985.                     (lit) 50 basePriority !    (( base priority of new tasks )) 
  986.                     (lit) 1  eventSlice !    (( how much time Mac receives ))
  987.                     (lit) 4  eventDelay !    (( how often event loop will be called ))
  988.                     demoInfo boot ;; 0
  989. :: boot 5            Root >self hello reboot shell ;; 0
  990.